home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 22 / Cream of the Crop 22.iso / program / tdk_v120.zip / _EXIT.PAS next >
Pascal/Delphi Source File  |  1996-07-15  |  8KB  |  211 lines
  1. {
  2.  ▀▀▀▀▀▀▀▀  ▀▀▀▀▀▀    ▀▀   ▀▀
  3.    ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  4.   ▀▀     ▀▀   ▀▀▀  ▀▀▀▀▀  The DoorKit!
  5.  ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  6. ▀▀     ▀▀▀▀▀▀    ▀▀    ▀▀
  7. The BBS Door Development Kit By The People - For The People!
  8.  
  9.  
  10.    Feel free to modify or optimize this code at will. All I ask is that if
  11.    find a better way to do things (and you will), please send me a copy of
  12.    your modifications. Thanks in advance!....Larry L. Athey....}
  13.  
  14. UNIT _EXIT;
  15.  
  16. {  This unit should be placed before ALL other unit names in the USES clause
  17.    in your main program source. This assures that the new handlers below are
  18.    installed before anything else. If you have any unit that must go before
  19.    this one than that's ok, but if that unit allocates any memory in its Init
  20.    section, it cannot rely on the memory handler that this unit creates. One
  21.    more thing to keep in mind is if you put any unit before this one in the
  22.    USES clause and a runtime error occures in that unit, this unit will not
  23.    be able to log it.
  24.  
  25.     This unit will do the following:
  26.     --------------------------------
  27.  1. Installs a new exit procedure. If your program is halted by some sort of
  28.     internal error this will bypass the Pascal exit procedure and display a
  29.     better discription of the error as well as "Error Logging" the error.
  30.  
  31.  2. Saves and restores the HEAP marker automatically. This means that you
  32.     don't have to use dispose or freemem before your program exits, because
  33.     this will free the entire heap that was used, so you don't have to do a
  34.     thing!
  35.  
  36.  3. Installs a new memory handler. If you try to allocate a chunk of memory
  37.     to something and there's not enough heap, instead of halting with an
  38.     out of memory error like TP does, this will continue normally with the
  39.     program, but the variable that you tried to assign the memory to will
  40.     have the value NIL. This makes it easier to do error checks when
  41.     allocating memory.}
  42.  
  43. INTERFACE
  44.  
  45. USES DOS;
  46.  
  47. CONST
  48.   MAX_ExitProcs = 16; {Adjust as needed, up to 256 processes allowed.}
  49.  
  50. TYPE
  51.   TExitProc = PROCEDURE;
  52.   TProcAry  = ARRAY[1..Max_ExitProcs] OF tExitProc; {Ary=1024 bytes}
  53.  
  54. FUNCTION AddtoExitChain(Proc : tExitProc) : BOOLEAN;
  55. {^ This adds a procedure to the "Exit Chain". Any procedures in the Exit
  56.    Chain are called when your program ends, automatically...No matter how
  57.    the program gets terminated (Normally, Carrier Drop, HALT(), ^C).
  58.  
  59.    Proc = Procedure to add. The procedure cannot have any parameters,
  60.           and MUST be compiled FAR. And to be safe, the location of the
  61.           procedure should not be an Overlayed unit. (I'm not sure what
  62.           would happen, probably nothing....Still, just to be safe....)
  63.  
  64.    The procedures are called in a "LIFO" (Last In First Out) fashion. This
  65.    is so the Comport routines will be the very last thing to DeInit itself.
  66.    For 2 reasons. 1] So you don't have to worry about Calling DeInitComport
  67.    at the end of your program. The DoorKit adds its own procedure to the
  68.    ExitChain to DeInit itself for you (it's always the very first procedure
  69.    in the chain)  2] Since The DoorKit itself is last to be shut down, any
  70.    of your procedures in the Exit Chain can use the comport still, if you
  71.    need / want to (so long as you don't call DeInitComport yourself!)....}
  72.  
  73. IMPLEMENTATION
  74.  
  75. TYPE
  76.   String10 = STRING[10];
  77.  
  78. CONST
  79.   ChainNum : INTEGER = 0;
  80.  
  81. VAR
  82.   ExitChain     : TProcAry;
  83.   SavedExitProc : POINTER;
  84.   Hp            : POINTER;
  85.  
  86. CONST
  87.   Hx : ARRAY[0..15] OF CHAR = '0123456789ABCDEF';
  88.  
  89. {───────────────────────────────────────────────────────────────────────────}
  90. FUNCTION AddtoExitChain;
  91. BEGIN
  92.   AddtoExitChain := FALSE;
  93.   IF (ChainNum < MAX_ExitProcs) AND (@Proc <> NIL) THEN BEGIN
  94.     INC(ChainNum);
  95.     ExitChain[ChainNum] := Proc;
  96.     AddtoExitChain := TRUE;
  97.   END;
  98. END;
  99. {───────────────────────────────────────────────────────────────────────────}
  100. FUNCTION Hex2(B : BYTE) : String10;
  101. BEGIN
  102.   Hex2 := Hx[(B SHR 4) AND 15] + Hx[B AND 15];
  103. END;
  104. {───────────────────────────────────────────────────────────────────────────}
  105. FUNCTION Hex4(W : WORD) : String10;
  106. BEGIN
  107.   Hex4 := Hex2(HI(W)) + Hex2(LO(W));
  108. END;
  109. {───────────────────────────────────────────────────────────────────────────}
  110. FUNCTION CustomHeapError(Size : WORD) : INTEGER; Far;
  111. BEGIN
  112.   CustomHeapError := 1;
  113. END;
  114. {───────────────────────────────────────────────────────────────────────────}
  115. FUNCTION ErrorMessage(ECode : WORD) : STRING;
  116. BEGIN
  117.   CASE ECode OF
  118.       1 : ErrorMessage := 'Invalid function number.';
  119.       2 : ErrorMessage := 'File not found.';
  120.       3 : ErrorMessage := 'Path not found.';
  121.       4 : ErrorMessage := 'Too many open files.';
  122.       5 : ErrorMessage := 'File access denied.';
  123.       6 : ErrorMessage := 'Invalid file handle.';
  124.      12 : ErrorMessage := 'Invalid file access code.';
  125.      15 : ErrorMessage := 'Invalid drive number.';
  126.      16 : ErrorMessage := 'Cannot remove current directory.';
  127.      17 : ErrorMessage := 'Cannot rename across drives.';
  128.      18 : ErrorMessage := 'No more files.';
  129.     100 : ErrorMessage := 'Disk read error.';
  130.     101 : ErrorMessage := 'Disk write error.';
  131.     102 : ErrorMessage := 'File not assigned.';
  132.     103 : ErrorMessage := 'File not open.';
  133.     104 : ErrorMessage := 'File not open for input.';
  134.     105 : ErrorMessage := 'File not open for output.';
  135.     106 : ErrorMessage := 'Invalid numeric format.';
  136.     150 : ErrorMessage := 'Disk is write-protected.';
  137.     151 : ErrorMessage := 'Bad drive request struct length.';
  138.     152 : ErrorMessage := 'Drive not ready.';
  139.     154 : ErrorMessage := 'CRC error in data.';
  140.     156 : ErrorMessage := 'Disk seek error.';
  141.     157 : ErrorMessage := 'Unknown media type.';
  142.     158 : ErrorMessage := 'Sector Not Found.';
  143.     159 : ErrorMessage := 'Printer out of paper.';
  144.     160 : ErrorMessage := 'Device write fault.';
  145.     161 : ErrorMessage := 'Device read fault.';
  146.     162 : ErrorMessage := 'Hardware failure.';
  147.     200 : ErrorMessage := 'Division by zero.';
  148.     201 : ErrorMessage := 'Range check error.';
  149.     202 : ErrorMessage := 'Stack overflow error.';
  150.     203 : ErrorMessage := 'Heap overflow error.';
  151.     204 : ErrorMessage := 'Invalid pointer operation.';
  152.     205 : ErrorMessage := 'Floating point overflow.';
  153.     206 : ErrorMessage := 'Floating point underflow.';
  154.     207 : ErrorMessage := 'Invalid floating point operation.';
  155.     208 : ErrorMessage := 'Overlay manager not installed.';
  156.     209 : ErrorMessage := 'Overlay file read error.';
  157.     210 : ErrorMessage := 'Object not initialized.';
  158.     211 : ErrorMessage := 'Call to abstract method.';
  159.     212 : ErrorMessage := 'Stream registration error.';
  160.     213 : ErrorMessage := 'Collection index out of range.';
  161.     214 : ErrorMessage := 'Collection overflow error.';
  162.     215 : ErrorMessage := 'Arithmetic overflow error.';
  163.     216 : ErrorMessage := 'General Protection fault.';
  164.   END;
  165. END;
  166. {───────────────────────────────────────────────────────────────────────────}
  167. PROCEDURE CustomExit; Far;
  168. VAR
  169.   I       : INTEGER;
  170.   Txt     : TEXT;
  171.   Msg     : STRING;
  172.   DirInfo : SearchRec;
  173. BEGIN
  174.   IF ErrorAddr <> NIL THEN BEGIN
  175.     Msg := ErrorMessage(ExitCode);
  176.     Asm mov ax,3; INT 10h END;
  177.     WRITELN('■ A RunTime Error Has Occured - Program Halted....');
  178.     WRITELN('  Address  = ',Hex4(SEG(ErrorAddr^)),':',Hex4(OFS(ErrorAddr^)));
  179.     WRITELN('  ExitCode = ',ExitCode);
  180.     WRITELN('  Error    = ',Msg);
  181.     WRITELN;
  182.     ASSIGN(Txt,'ERROR.LOG');
  183.     FINDFIRST('ERROR.LOG',Archive,DirInfo);
  184.     IF DOSERROR <> 0 THEN BEGIN
  185.       REWRITE(Txt);
  186.       CLOSE(Txt);
  187.     END;
  188.     APPEND(Txt);
  189.     WRITELN(Txt,'■ A RunTime Error Has Occured - Program Halted....');
  190.     WRITELN(Txt,'  Address  = ',Hex4(SEG(ErrorAddr^)),':',Hex4(OFS(ErrorAddr^)));
  191.     WRITELN(Txt,'  ExitCode = ',ExitCode);
  192.     WRITELN(Txt,'  Error    = ',Msg);
  193.     WRITELN(Txt);
  194.     CLOSE(Txt);
  195.     RESET(Input);
  196.     ErrorAddr := NIL;
  197.     ExitCode  := 0;
  198.   END;
  199.   FOR I := ChainNum DOWNTO 1 DO IF @ExitChain[I] <> NIL THEN ExitChain[I];
  200.   RELEASE(Hp);
  201.   ExitProc := SavedExitProc;
  202. END;
  203. {───────────────────────────────────────────────────────────────────────────}
  204.  
  205. BEGIN
  206.   SavedExitProc := ExitProc;
  207.   ExitProc      := @CustomExit;
  208.   HeapError     := @CustomHeapError;
  209.   MARK(Hp);
  210. END.
  211.